home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-taspri.adb < prev    next >
Text File  |  1994-05-19  |  23KB  |  745 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --                S Y S T E M . T A S K _ P R I M I T I V E S               --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.6 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                          --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2,  or (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Unchecked_Deallocation;
  27. with System.POSIX_Error; use System.POSIX_Error;
  28. with System.POSIX_timers;
  29.  
  30. with Unchecked_Conversion;
  31.  
  32. package body System.Task_Primitives is
  33.  
  34.    Abort_Signal : constant Signal := SIGUSR1;
  35.  
  36.    function "=" (L, R : System.Address) return Boolean
  37.      renames System."=";
  38.  
  39.    ATCB_Key : pthread_key_t;
  40.  
  41.    Abort_Handler : Abort_Handler_Pointer;
  42.  
  43.    LL_Signals       : Signal_Set;
  44.    Task_Signal_Mask : Signal_Set;
  45.  
  46.    Reserved_Signals : Signal_Set;
  47.  
  48.    Assertions_Checked : constant Boolean := True;
  49.  
  50.    procedure Put_Character (C : Integer);
  51.    pragma Import (C, Put_Character, "putchar");
  52.  
  53.    procedure Prog_Exit (Status : Integer);
  54.    pragma Import (C, Prog_Exit, "exit");
  55.  
  56.    function Pointer_to_Address is new
  57.      Unchecked_Conversion (TCB_Ptr, System.Address);
  58.  
  59.    function Address_to_Pointer is new
  60.      Unchecked_Conversion (System.Address, TCB_Ptr);
  61.  
  62.    -----------------------
  63.    -- Local Subprograms --
  64.    -----------------------
  65.  
  66.    function Get_Stack_Limit return System.Address;
  67.    pragma Inline (Get_Stack_Limit);
  68.    --  Obtains stack limit from TCB
  69.  
  70.    procedure Assert (B : Boolean; M : String);
  71.    pragma Inline (Assert);
  72.    --  Output string M if B is True and Assertions_Checked
  73.  
  74.    procedure Write_Character (C : Character);
  75.    procedure Write_EOL;
  76.    procedure Write_String (S : String);
  77.    --  Debugging procedures used for assertion output
  78.  
  79.    ---------------------
  80.    -- Write_Character --
  81.    ---------------------
  82.  
  83.    procedure Write_Character (C : Character) is
  84.    begin
  85.       Put_Character (Character'Pos (C));
  86.    end Write_Character;
  87.  
  88.    ---------------
  89.    -- Write_Eol --
  90.    ---------------
  91.  
  92.    procedure Write_EOL is
  93.    begin
  94.       Write_Character (Ascii.LF);
  95.    end Write_EOL;
  96.  
  97.    ------------------
  98.    -- Write_String --
  99.    ------------------
  100.  
  101.    procedure Write_String (S : String) is
  102.    begin
  103.       for J in S'range loop
  104.          Write_Character (S (J));
  105.       end loop;
  106.    end Write_String;
  107.  
  108.    ---------------
  109.    -- LL_Assert --
  110.    ---------------
  111.  
  112.    procedure LL_Assert (B : Boolean; M : String) is
  113.    begin
  114.       if not B then
  115.          Write_String ("Failed assertion: ");
  116.          Write_String (M);
  117.          Write_String (".");
  118.          Write_EOL;
  119.          Prog_Exit (1);
  120.       end if;
  121.    end LL_Assert;
  122.  
  123.    ------------
  124.    -- Assert --
  125.    ------------
  126.  
  127.    procedure Assert (B : Boolean; M : String) is
  128.    begin
  129.       if Assertions_Checked then
  130.          LL_Assert (B, M);
  131.       end if;
  132.    end Assert;
  133.  
  134.    -------------------------
  135.    -- Initialize_LL_Tasks --
  136.    -------------------------
  137.  
  138.    procedure Initialize_LL_Tasks (T : TCB_Ptr) is
  139.       Old_Set : Signal_Set;
  140.       Mask    : Signal_Set;
  141.       Result  : Return_Code;
  142.  
  143.    begin
  144.    --  WARNING : SIGALRM should not be in the following mask.  SIGALRM should
  145.    --          be a normal user signal under 1, and should be enabled
  146.    --          by the client.  However, the current RTS built on 1
  147.    --          uses nanosleep () and pthread_cond_wait (), which fail if all
  148.    --          threads have SIGALRM masked. ???
  149.  
  150.       Delete_All_Signals (LL_Signals);
  151.       Add_Signal (LL_Signals, Abort_Signal);
  152.       Add_Signal (LL_Signals, SIGALRM);
  153.       Add_Signal (LL_Signals, SIGILL);
  154.       Add_Signal (LL_Signals, SIGABRT);
  155.       Add_Signal (LL_Signals, SIGFPE);
  156.       Add_Signal (LL_Signals, SIGSEGV);
  157.       Add_Signal (LL_Signals, SIGPIPE);
  158.       Add_All_Signals (Task_Signal_Mask);
  159.       Delete_Signal (Task_Signal_Mask, Abort_Signal);
  160.       Delete_Signal (Task_Signal_Mask, SIGALRM);
  161.       Delete_Signal (Task_Signal_Mask, SIGILL);
  162.       Delete_Signal (Task_Signal_Mask, SIGABRT);
  163.       Delete_Signal (Task_Signal_Mask, SIGFPE);
  164.       Delete_Signal (Task_Signal_Mask, SIGSEGV);
  165.       Delete_Signal (Task_Signal_Mask, SIGPIPE);
  166.  
  167.       Delete_Signal (Task_Signal_Mask, SIGTRAP);
  168.       --  Not POSIX; this is left unmasked to keep SGI dbx happy.
  169.  
  170.       pthread_init;
  171.  
  172.       Delete_All_Signals (Reserved_Signals);
  173.       Add_Signal (Reserved_Signals, SIGILL);
  174.       Add_Signal (Reserved_Signals, SIGABRT);
  175.       Add_Signal (Reserved_Signals, SIGFPE);
  176.       Add_Signal (Reserved_Signals, SIGSEGV);
  177.       Add_Signal (Reserved_Signals, SIGPIPE);
  178.       Add_Signal (Reserved_Signals, Abort_Signal);
  179.  
  180.       pthread_key_create (ATCB_Key, System.Null_Address, Result);
  181.  
  182.       if Result = Failure then
  183.          raise Storage_Error;               --  Insufficiant resources.
  184.       end if;
  185.  
  186.       sigprocmask (SIG_SETMASK, Task_Signal_Mask, Old_Set, Result);
  187.       Assert (Result /= Failure, "GNULLI failure---sigprocmask");
  188.  
  189.       T.LL_Entry_Point := null;
  190.  
  191.       T.Thread := pthread_self;
  192.       pthread_setspecific (ATCB_Key, Pointer_to_Address (T), Result);
  193.       Assert (Result /= Failure, "GNULLI failure---pthread_setspecific");
  194.  
  195.    end Initialize_LL_Tasks;
  196.  
  197.    ----------
  198.    -- Self --
  199.    ----------
  200.  
  201.    function Self return TCB_Ptr is
  202.       Temp   : System.Address;
  203.       Result : Return_Code;
  204.  
  205.    begin
  206.       pthread_getspecific (ATCB_Key, Temp, Result);
  207.       Assert (Result /= Failure, "GNULLI failure---pthread_getspecific");
  208.       return Address_to_Pointer (Temp);
  209.    end Self;
  210.  
  211.    ---------------------
  212.    -- Initialize_Lock --
  213.    ---------------------
  214.  
  215.    procedure Initialize_Lock
  216.      (Prio : System.Priority;
  217.       L    : in out Lock)
  218.    is
  219.       Attributes : pthread_mutexattr_t;
  220.       Result     : Return_Code;
  221.  
  222.    begin
  223.       pthread_mutexattr_init (Attributes, Result);
  224.       if Result = Failure then
  225.          raise STORAGE_ERROR;  --  should be ENOMEM
  226.       end if;
  227.  
  228.       pthread_mutexattr_setprotocol (Attributes, PRIO_PROTECT, Result);
  229.  
  230.       Assert (Result /= Failure,
  231.         "GNULLI failure---pthread_mutexattr_setprotocol");
  232.  
  233.       pthread_mutexattr_setprio_ceiling (Attributes, Prio, Result);
  234.  
  235.       Assert (Result /= Failure,
  236.         "GNULLI failure---pthread_mutexattr_setprio_ceiling");
  237.  
  238.       pthread_mutex_init (pthread_mutex_t (L), Attributes, Result);
  239.  
  240.       if Result = Failure then
  241.          raise STORAGE_ERROR;  --  should be ENOMEM ???
  242.       end if;
  243.    end Initialize_Lock;
  244.  
  245.    -------------------
  246.    -- Finalize_Lock --
  247.    -------------------
  248.  
  249.    procedure Finalize_Lock (L : in out Lock) is
  250.       Result : Return_Code;
  251.  
  252.    begin
  253.       pthread_mutex_destroy (pthread_mutex_t (L), Result);
  254.       Assert (Result /= Failure, "GNULLI failure--